home *** CD-ROM | disk | FTP | other *** search
/ BCI NET 2 / BCI NET 2.iso / archives / programming / e / amigae30a_fr.lha / AmigaE30f / Sources / Lang / Forth.e next >
Encoding:
Text File  |  1993-11-09  |  4.1 KB  |  134 lines
  1. /* TinyForth, un petit intepréteur Forth
  2.    pas de fonction *encore*, peut être utilisé comme une calculatrice
  3.    avec pile pour le plaisir.
  4.    Se termine avec QUIT<cr> ou <ctrl-c><cr>
  5.    Traduction : Olivier ANH (BUGSS)                                    */
  6.  
  7. CONST MAXSTACK=1000,MAXRSTACK=200
  8. ENUM NO_MES,OK,ER_UNDERFLOW,ER_OVERFLOW,ER_SYM
  9.  
  10. DEF con,stop=FALSE,error=OK,crflag=TRUE,
  11.     inp[100]:STRING,
  12.     item[50]:STRING, item2[50]:STRING,
  13.     stack[MAXSTACK]:ARRAY OF LONG, rstack[MAXRSTACK]:ARRAY OF LONG,
  14.     sp:PTR TO LONG, rsp:PTR TO LONG
  15.  
  16. PROC main()
  17.   con:=Open('CON:0/11/640/100/TinyForth',1005)
  18.   IF con
  19.     stdout:=con
  20.     WriteF('Interpréteur TinyForth v0.1 (c) 1992 by $#%!\n')
  21.     sp:=stack; rsp:=rstack
  22.     REPEAT
  23.       puterror()
  24.       WriteF('>')
  25.       ReadStr(con,inp)
  26.       IF CtrlC() THEN stopnow()
  27.       error:=OK; crflag:=TRUE
  28.       eval(inp)
  29.     UNTIL stop
  30.     Close(con)
  31.   ENDIF
  32. ENDPROC
  33.  
  34. PROC eval(c)
  35.   DEF pos,end,symlong,p,i,j,k
  36.   pos:=c; end:=c+EstrLen(c)
  37.   WHILE (pos<end) AND (error<=OK)
  38.     IF CtrlC() THEN stopnow()
  39.     pos:=getsym(pos)
  40.     StrCopy(item2,item,ALL)
  41.     UpperStr(item2)
  42.     StrAdd(item2,'   ',3)
  43.     symlong:=Long(item2)
  44.     SELECT symlong
  45.       CASE "DUP "; i:=pop(); push(i); push(i)
  46.       CASE "DROP"; pop()
  47.       CASE "SWAP"; i:=pop(); j:=pop(); push(i); push(j)
  48.       CASE "OVER"; i:=pop(); j:=pop(); push(j); push(i); push(j)
  49.       CASE "ROT "; i:=pop(); j:=pop(); k:=pop(); push(j); push(i); push(k)
  50.       CASE "PICK"; i:=pop(); IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE push(sp[-i])
  51.       CASE "ROLL"; i:=pop(); j:=sp[-i]; IF sp-(i*4)<stack THEN error:=ER_UNDERFLOW ELSE FOR k:=-i TO -2 DO sp[k]:=sp[k+1]; pop(); push(j)
  52.       CASE "?DUP"; i:=pop(); push(i); IF i THEN push(i)
  53.       CASE "DEPT"; push(sp-stack/4)
  54.       CASE ">R  "; rpush(pop())
  55.       CASE "R>  "; push(rpop())
  56.       CASE "R@  "; i:=rpop(); push(i); rpush(i)
  57.  
  58.       CASE "<   "; push(Not(pop()<=pop()))
  59.       CASE "=   "; push(pop()=pop())
  60.       CASE ">   "; push(Not(pop()>=pop()))
  61.       CASE "0<  "; push(pop()<0)
  62.       CASE "0=  "; push(0=pop())
  63.       CASE "0>  "; push(pop()>0)
  64.       CASE "D<  "; push(Not(pop()<=pop()))
  65.       CASE "U<  "; push(Not(pop()<=pop()))
  66.       CASE "NOT "; push(Not(pop()))
  67.  
  68.       CASE ".   "; WriteF('\d ',pop()); crflag:=FALSE
  69.       CASE "CR  "; WriteF('\n'); crflag:=TRUE
  70.       CASE "EMIT"; WriteF('\c',pop()); crflag:=FALSE
  71.       CASE "TYPE"; i:=pop(); j:=pop(); FOR k:=1 TO i DO WriteF('\c',j[]++)
  72.       CASE "SPAC"; IF Long(item2+4)="E   " THEN i:=1 ELSE i:=pop(); FOR j:=1 TO i DO WriteF(' '); crflag:=FALSE
  73.  
  74.       CASE "+   "; push(pop()+pop())
  75.       CASE "-   "; i:=pop(); push(pop()-i)
  76.       CASE "*   "; push(Mul(pop(),pop()))
  77.       CASE "/   "; i:=pop(); push(Div(pop(),i))
  78.  
  79.       CASE "ABOR"; sp:=stack
  80.       CASE "QUIT"; stop:=TRUE
  81.       DEFAULT
  82.         IF Int(item)=$2E22      /* ." construction */
  83.           crflag:=FALSE
  84.           Write(stdout,item+2,EstrLen(item)-3)
  85.         ELSE
  86.           IF item[0]="-" THEN p:=item+1 ELSE p:=item
  87.           i:=Val(p,{j})
  88.           IF (j=0) THEN error:=ER_SYM
  89.           IF p<>item THEN i:=Mul(i,-1)
  90.           push(i)
  91.        ENDIF
  92.     ENDSELECT
  93.   ENDWHILE
  94. ENDPROC
  95.  
  96. PROC pop() RETURN IF sp<=stack THEN error:=ER_UNDERFLOW ELSE sp[]--
  97. PROC rpop() RETURN IF rsp<=rstack THEN error:=ER_UNDERFLOW ELSE rsp[]--
  98. PROC push(val); IF MAXSTACK*4+stack<=sp THEN error:=ER_OVERFLOW ELSE sp[]++:=val; ENDPROC
  99. PROC rpush(val); IF MAXRSTACK*4+rstack<=rsp THEN error:=ER_OVERFLOW ELSE rsp[]++:=val; ENDPROC
  100.  
  101. PROC getsym(p)
  102.   DEF p2
  103.   p:=TrimStr(p)
  104.   IF p[0]="("
  105.     p2:=InStr(p,')',0)
  106.     IF p2=-1 THEN p2:=1000
  107.     p:=TrimStr(p+p2+1)
  108.   ENDIF
  109.   IF p[0]="." AND p[1]=34
  110.     p2:=InStr(p,'"',2)
  111.     IF p2=-1 THEN p2:=1000 ELSE INC p2
  112.     StrCopy(item,p,p2)
  113.   ELSE
  114.     p2:=InStr(p,' ',0)
  115.     IF p2=-1 THEN p2:=1000
  116.     StrCopy(item,p,p2)
  117.   ENDIF
  118. ENDPROC p+p2+1
  119.  
  120. PROC puterror()
  121.   IF crflag=FALSE THEN WriteF('\n')
  122.   SELECT error
  123.     CASE OK;           WriteF('Ok.\n')
  124.     CASE ER_UNDERFLOW; WriteF('PILE UNDERFLOW.\n')
  125.     CASE ER_OVERFLOW;  WriteF('DEPACEMENT DE LA PILE.\n')
  126.     CASE ER_SYM;       WriteF('\s?\n',item)
  127.   ENDSELECT
  128. ENDPROC
  129.  
  130. PROC stopnow()
  131.   Close(con)
  132.   CleanUp(0)
  133. ENDPROC
  134.